perm filename EMACLS.11[MAC,LSP] blob
sn#587535 filedate 1981-05-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00022 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 MacLisp portion of the E/MacLisp Interface.
C00011 00003 αxSLISP dsk:maclsp.dmp[1,3](elisp.ini)
C00020 00004 (lap em:MAIL-interface subr)
C00024 00005 (entry em:mail-type subr)
C00029 00006 (entry em:wait-mail subr)
C00031 00007 (entry em:mail-sfa subr)
C00034 00008 TYI
C00037 00009 TYO
C00039 00010 FORCE OUTPUT
C00042 00011 Routine to get to a buffer from E with not all <cr>s in it
C00043 00012 This routine gets fresh mail to initialize the reader
C00048 00013 This routine does a jobread into the right spot.
C00050 00014 wait-ok
C00051 00015 (entry em:send-simple-message subr)
C00054 00016 (entry em:send-control-char subr)
C00056 00017 (entry em:init subr)
C00057 00018 send-ok
C00058 00019 (entry em:eval-protect subr)
C00059 00020 Routines for obtaining the values of readonly variables
C00065 00021 debugging routines
C00066 00022 Storage for Mail routines
C00069 ENDMK
C⊗;
;;; MacLisp portion of the E/MacLisp Interface.
;;;
;;; An SFA/MAIL based system for communicating with
;;; an unstructured, standard text editor.
;;; Starts with -em:jobnum- figured out from E.
;;; (sfa-call <sfa> 'send-lines n)
;;; sets the number of lines that are sent at one time to n.
;;; normal is T (meaning send every line).
;;; NIL means never send.
;;; (sfa-call <sfa> 'report-send-lines) returns the value
;;; (ecalledp) defined in (HELP) tells whether E called you
(declare (mapex t)
(setq defmacro-for-compiling ())
(special -em:jobnum- -em:e-commands- -em:sfa- -em:errorp-
-em:mail-input-buffer-dry-handler-
-em:filemode- grlinel)
(*lexpr em:fread)
(fixnum -em:jobnum-))
(setq -em:e-commands- ()
-em:mail-input-buffer-dry-handler- ()
-em:filemode- ()
grlinel (linel t))
(defun em:mail-interface-initialize ()
(em:eval-protect)
(em:initialize)
(princ '|MacLisp Ready|)(terpri)
(sfa-call -em:sfa- 'force-output ())
)
(setq -em:sfa- ())
(sstatus ttyint 232. '+internal-↑B-break)
(sstatus ttyint 200. '+internal-↑B-break)
(defun em:initialize ()
(em:get-jobnum)
(em:init)
(em:init-send-lines)
(setq -em:sfa- (sfa-create (function em:mail-sfa) 0 'mail-sfa))
(setq tyi -em:sfa-)
(setq tyo -em:sfa-)
; (em:send-simple-message 'ok -em:jobnum-)
t)
(defmacro unascii (x)
`(car (exploden ,x)))
(defun em:ecommands (l)
(sfa-call -em:sfa- 'force-output ())
(let ((-em:e-commands- t))
(do ((com l (cdr com)))
((null com)(sfa-call -em:sfa- 'force-output ()))
(cond ((eq (car com) '<cr>)
(sfa-call -em:sfa- 'tyo '(⊗ ↔)))
((eq (car com) '<lf>)
(sfa-call -em:sfa- 'tyo '(⊗ ↓)))
(t
(sfa-call -em:sfa- 'tyo
(unascii (car com))))))))
(defun em:set-send-lines (n)
(sfa-call -em:sfa- 'send-lines n))
(defun em:get-send-lines ()
(sfa-call -em:sfa- 'report-send-lines ()))
(defun em:force ()
(sfa-call -em:sfa- 'force-output ()))
(defun em:terpri () (terpri -em:sfa-))
(defun em:eval-until-eof ()
((lambda (eof)
(em:file-align)(em:set-send-lines t)
(do ((form (em:fread eof) (em:fread eof))
(l nil))
((eq form eof)
(do ((i (nreverse l) (cdr i)))
((null i)
(sfa-call -em:sfa- 'force-output ())
(em:set-send-lines ()))
(print (car i))))
(setq l (cons (eval form) l)))) (ncons ())))
(defun em:fread n
((lambda (-em:filemode-)
(cond ((zerop n)
(read))
((= n 1)
(read (arg 1)))
((= n 2)
(read (arg 1)(arg 2)))
(t
(break |too many args to FREAD| t))))
t))
(defun em:control-dispatch (char)
(cond ((member char '(#o302 #o342))
(funcall '+internal-↑B-break -em:sfa- char))
((member char '(#o303 #o343))
(setq ↑D ()))
((member char '(#o304 #o344))
(setq ↑D t))
(t ((lambda (fun)
(cond (fun (funcall fun -em:sfa- char))))
(status ttyint char)))))
(defun em:readonly-vars (l)
;make up message and initial (sixbit . ascii) alist
(em:readonly-init)
(cond ((> (length l) 25.)
(do ((rest l (cdr rest))
(i 25. (1- i))
(first25 ()))
((= i 0)
(append
(em:readonly-vars first25)
(em:readonly-vars rest)))
(push (car l) first25)))
(t
(setq l
(mapcar #'(lambda (x)
(subst () ()
`(,(em:make-sixbit x)
,x () ())))
l))
(em:force-readonly-message)
(do ((nxt (em:get-next-readonly)
(em:get-next-readonly))
(entry))
((equal nxt -1)
(mapcan #'(lambda (x)
(cond
((caddr x)
`((,(cadr x) . ,(cadddr x))))))
l))
(cond ((setq entry (assoc (car nxt) l))
(rplaca (cdddr entry) (cdr nxt))
(rplaca (cddr entry) t)))))))
(declare (special em:line em:lines em:page em:pages))
(defun em:send-next-line ()
(let ((-em:mail-input-buffer-dry-handler- ()))
(cond ((= em:lines em:line)
(cond ((= em:page em:pages)
(break |No right paren found| t))
(t (em:ecommands
'(α p))
(setq em:line 1
em:page (1+ em:page)
em:lines
(cdr (assq 'lines
(em:readonly-vars '(lines)))))
(em:ecommands '(α =)))))
(t (em:ecommands '(⊗ ↔ α =))
(setq em:line (1+ em:line))))))
(defun em:eval-sexp ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq em:line (cdr (assq 'line alist))
em:lines (cdr (assq 'lines alist))
em:page (cdr (assq 'page alist))
em:pages (cdr (assq 'pages alist))))
(let ((-em:mail-input-buffer-dry-handler- 'em:send-next-line))
(print (eval (read)))))
;;; αxSLISP dsk:maclsp.dmp[1,3](elisp.ini)
;;; αnαxSLISP talks to job n(10.)
;;; α0αxSLISP types the wholine of inferior
;;; α-αxSLISP murder (i.e. negotiated suicide)
;;; α= send arrow line or attach buffer
;;; α+nα= send next n lines
;;; α-nα= send previous n lines
;;; αx= <sexp>
;;; send comand line
;;;
;;; Protocols: (* means not actually anticipated to be used; current
;;; implementation knows about it but does not send and/or interpret them
;;; specially)
;;;
;;; From E to MacLisp
;;; Mail
;;; wd0: Job# sending message
;;; wd1: type of message
;;;
;;; 2,,0: Continuation needed
;;; 1,,0: Short (fits in the next =30 words, ends with null byte
;;; or falls off)
;;;
;;; 0 no-op
;;; 1 initiating a conversation
;;; 2 ok (did the jobread)
;;; 3 SEXPs
;;; 4 explicit eof
;;; 5 control (meta) chars to follow (E macro format)
;;; (or E commands (from MacLisp to E))
;;; 6 interrupt. do <esc>i <char>
;;; 7 close connection (suicide)
;;;
;;; wd2: -number of bytes,,address of buffer
;;;
;;;
;;; E commands will be represented in the standard E macro manner
;;; (unless there is something better).
;;;
;;;
;;; Protocol is:
;;; E MacLisp
;;; ---------------
;;; initiate
;;; ok
;;;
;;; To send a short message just a MAIL
;;; To send a long message MAIL then wait for JOBREAD acknowledge
;;; To send interrupts, just send them
;;; Acknowledgment is the short OK message
;;;
;;; Commands needed:
;;; start DMP file
;;; send control chars
;;; send interrupt character (just 1 at a time)
;;;
(lap em:MAIL-interface subr)
(defsym rovmailblksize 50.)
(defsym mlblksize 32.)
(defsym freeac #o13)
(defsym cntrl-bit #o200)
(defsym meta-bit #o400)
(defsym ccntrlg #o307)
(defsym cntrlg #o347)
(defsym ccntrlx #o330)
(defsym cntrlx #o370)
(defsym EPR #o456062)
(defsym noutbytes #o10000)
(defsym nrovbytes #o1000)
(defsym rdblk #o2000)
(defsym blksize #o2000)
(defsym maxshort 145.)
(defsym rovmaxshort 29.)
(defsym lf #o12)
(defsym cr #o15)
(defsym noop-type 0)
(defsym initiate-type 1)
(defsym ok-type 2)
(defsym sexp-type 3)
(defsym explicit-eof-type 4)
(defsym ecommand-type 5)
(defsym interrupt-type 6)
(defsym kill-type 7)
(defsym readonlyvar-type 8.)
(defsym high-command 8.)
(defsym space #o40)
(defsym tab #o11)
(defsym alpha 2)
(defsym beta 3)
(defsym cont-bit 2)
(defsym short-bit 1)
(defsym meta-mask 400)
(defsym control-mask 200)
em:process-mail
(setzm 0 tyi-inited)
(setzm 0 (special sail-mail-interrupt))
(hlrz tt mailbox) ;get EPR half
(caie tt epr) ;is it EPR (in sixbit)?
(jrst 0 wrongj)
(hrrz tt mailbox) ;get the jobnum
(skipg 0 jobnum)
(jrst 0 gm1)
(came tt jobnum) ;correct one?
(jrst 0 wrongj)
gm3 (movem tt jobread)
(move tt (+ mailbox 1)) ;type bits
(jrst 0 em:mail-type)
;;; Silly jobnum was never set
gm1 (movem tt jobnum)
(movem tt jobn2)
(jsp t fxcons) ;number cons
(movem a (special -em:jobnum-)) ;save it
(jrst 0 gm3)
true (movei a 't)
(popj p)
false (movei a 'nil)
(popj p)
(entry em:get-jobnum subr)
(args em:get-jobnum (nil . 0))
(move tt (special sail-mail-interrupt))
(movem tt jobnum)
(movem tt jobn2)
(jsp t fxcons) ;find that entry!
(movem a (special -em:jobnum-))
(setzm 0 (special sail-mail-interrupt))
(popj p)
(entry em:set-jobnum subr)
(args em:set-jobnum (nil . 1))
(move tt 0 a)
(movem a (special -em:jobnum-))
(movem tt jobnum)
(movem tt jobn2)
(popj p)
wrongj (movei a 'wrong-jobnum)
(popj p)
(entry em:mail-type subr)
(args em:mail-type (nil . 0))
em:mail-type
(setzm 0 explicit-eof) ;0 means nil
(setzm 0 forcedp)
(move tt (+ mailbox 1));type bits
(movei a 'nil) ;short flag
(tlne tt short-bit)
(movei a 't)
(movem a (special -em:shortp-))
(movei a 'nil)
(tlne tt cont-bit)
(movei a 't)
(movem a (special -em:contp-))
(hrrzs 0 tt) ;grumble, test for range
(skipge 0 tt) ;too low?
(jrst 0 unknown) ;yup, unknown
(caile tt high-command) ;too high
(jrst 0 unknown)
(jrst 0 @ type-disp tt) ;dispatch
unknown (movei a 'unknown)
(popj p)
type-disp
(0 0 no-op)
(0 0 initiate)
(0 0 ok)
(0 0 sexps)
(0 0 explicit-eof)
(0 0 e-command)
(0 0 interrupt)
(0 0 kill)
(0 0 readonlyvars)
e-command
(movei a 'ecommand)
(popj p)
no-op
(movei a 'no-op)
(popj p)
sexps
(skipge 0 inbytes)
; (jrst 0 snot-finished)
(calli 1 12) ;kill self
sresume (move a (+ mailbox 2)) ;get number of bytes
(move tt (+ mailbox 1)) ;type bits
(setzm 0 tyi-inited) ;tyi not inited
(hlrem a inbytes) ;store it
(hlre b a) ;-number of bytes
(idivi b 4) ;-number of words
(jumpe c ztesch)
(subi b 1) ;one more, bunkie
ztesch
(movem b inwords)
(move b inpointtem)
(movem b inpoint)
(skipe 0 withinrov)
(setom 0 delayedsexp)
(setzm 0 mailinp)
(tlne tt short-bit) ;short?
(jrst 0 tshort)
(pushj p transfer-buffer)
(movei a 'sexps)
(popj p)
tshort (pushj p transfer-short)
(movei a 'sexps)
(popj p)
initiate(movei a 'initiate)
(setzm 0 mailinp)
(popj p)
readonlyvars
(movei tt rovmail)
(movem tt transfer-spot)
(movei tt rovmailblksize)
(movem tt transfer-size)
(move a (+ mailbox 2)) ;number of bytes
(hlrem a rinbytes)
(movem a inwords)
(move a irovpointtem)
(movem a irovpoint)
(setzm 0 mailinp)
(move tt (+ mailbox 1)) ;type bits
(tlne tt short-bit) ;short?
(jrst 0 rtshort)
(pushj p transfer-buffer)
(movei a 'readonlyvars)
(popj p)
rtshort (pushj p transfer-short)
(movei a 'readonlyvars)
(popj p)
interrupt
(movei a 'interrupt)
(setzm 0 mailinp)
(popj p)
explicit-eof
(setom 0 explicit-eof)
(movei a 'eof)
(popj p)
ok
(movei a 'ok)
(setzm 0 mailinp)
(popj p)
kill (pushj p send-ok)
(calli 1 12) ;kill self
snot-finished
(setzm 0 tyi-inited)
(movei a sresume)
(movem a resume-pc)
(movei a 'sexps)
(popj p)
(entry em:wait-mail subr)
(args em:wait-mail (nil . 0))
em:wait-mail
(skipe 0 tyop)
(pushj p force2)
(skipe 0 (special sail-mail-interrupt))
(jrst 0 wm2)
(skipn 0 (special -em:mail-input-buffer-dry-handler-))
(jrst 0 wm1)
(pushj p em:call-handler)
wm1 (722←33 0 mailint) ;imskcl
(mail 1 mailbox) ;WRCV
(721←33 0 mailint) ;imskst
wm2 (setzm 0 (special sail-mail-interrupt))
(setom 0 mailinp) ;mail now in
(setzm 0 tyi-inited)
(movei a 't)
(popj p)
(entry em:mask-off subr)
(args em:mask-off (nil . 0))
(722←33 0 mailint) ;imskcl
(movei a 't)
(popj p)
(entry em:mask-on subr)
(args em:mask-on (nil . 0))
(721←33 0 mailint) ;imskst
(movei a 't)
(popj p)
em:call-handler
(movem freeac (+ svdacs 9.))
(movei freeac svdacs)
(hrli freeac b)
(blt freeac (+ svdacs 9.))
(setz b)
(movei freeac c)
(hrli freeac b)
(blt freeac freeac)
(move a (special -em:mail-input-buffer-dry-handler-))
(callf 0 0 1)
(hrlzi freeac svdacs)
(hrri freeac b)
(blt freeac freeac)
(skipn 0 delayedsexp)
(popj p)
(sub p (% 0 0 1 1))
(jrst 0 wm2)
(entry em:mail-sfa subr)
(args em:mail-sfa (nil . 3))
(movei a 0 b) ;operation type ignore the object
(caie a 'which-operations)
(jrst 0 t1)
(movei a '(tyi tyo terpri force-output untyi charpos linel
force-readonly-message send-lines report-send-lines))
(popj p)
t1 (cain a 'tyi) ;tyi?
(jrst 0 em:mail-tyi)
(cain a 'tyo) ;tyo?
(jrst 0 em:mail-tyo)
(cain a 'terpri)
(jrst 0 em:terpri)
(cain a 'force-output) ;force output?
(jrst 0 em:mail-force-output)
(cain a 'untyi) ;untyi?
(jrst 0 em:mail-untyi)
(cain a 'charpos)
(jrst 0 em:mail-charpos)
(cain a 'linel)
(jrst 0 em:mail-linel)
(cain a 'send-lines)
(jrst 0 isend-lines)
(cain a 'report-send-lines)
(jrst 0 report-send-lines)
(cain a 'force-readonly-message)
(jrst 0 em:force-readonly-message)
(movei a 'nil)
(popj p)
(entry em:mail-charpos subr)
(args em:mail-charpos (nil . 0))
em:mail-charpos
(move tt charpos)
(jrst 0 fix1)
em:mail-linel
(movei t g1)
(push p t)
(push p (% 0 0 't))
(movni t 1)
(jcall 16 'linel)
g1 (popj p)
isend-lines
(movem c send-lines)
(move c @ c)
(movem c skipp)
(movem c vsend-lines)
(movei a 't)
(popj p)
report-send-lines
(move a send-lines)
(popj p)
(entry em:init-send-lines subr)
(args em:init-send-lines (nil . 0))
(movei a (+ noutbytes 1))
(movem a outbytes)
(movei a (+ nrovbytes 1))
(movem a rovbytes)
(movei tt 0)
(movem tt vsend-lines)
(movem tt skipp)
(movei a 'NIL)
(movem a send-lines)
(popj p)
em:terpri
(setzm 0 )
(setzm 0 forcedp)
(setom 0 tyop)
(movei a cr)
(pushj p tyo1)
(movei a lf)
(jrst 0 tyo1)
;;; TYI
(entry em:mail-tyi subr)
em:mail-tyi
(skipe 0 explicit-eof)
(jrst 0 eeof)
(movem c eofchar)
(skipe 0 untyif)
(jrst 0 untyi2)
(skipn 0 tyi-inited) ;not inited?
(pushj p real-mail-refresh)
ityi (skipe 0 inbytes) ;and nothing left?
(jrst 0 tyi1)
(skipe 0 (special -em:contp-)) ;a continuation?
(jrst 0 tyi2)
(skipe 0 (special -em:filemode-)) ;in special file mode?
(jrst 0 reof)
tyi2 (pushj p mail-refresh)
tyi1 (aosle 0 inbytes)
(pushj p mail-refresh)
inmailok
(ildb tt inpoint) ;get byte
(trne tt cntrl-bit)
(jrst 0 pondercntrl)
(jrst 0 fix1) ;what a bum!
(pushj p mail-refresh)
(jrst 0 tyi1)
em:mail-untyi
(aos 0 untyif)
(move b untyipdl)
(push b c)
(movem b untyipdl)
(popj p)
untyi2 (move b untyipdl)
(sosl 0 untyif)
(pop b a)
(movem b untyipdl)
(popj p)
eeof (setzm 0 explicit-eof)
reof
(move a eofchar)
(sub p (% 0 0 1 1))
(popj p)
pondercntrl
(trnn tt meta-bit) ;foo it was control-meta
(jrst 0 tyi3)
(jrst 0 fix1) ;what a bum!
tyi3 (caie tt ccntrlg) ;↑G
(cain tt cntrlg) ;↑g
(call 0 '↑G)
(caie tt ccntrlx) ;↑X
(cain tt cntrlx) ;↑x
(jrst 0 ↑Xhandler)
(movei tt 0 tt)
(jsp t fxcons)
(call 1 'em:control-dispatch)
(jrst 0 em:mail-tyi)
↑Xhandler
(movei t em:mail-tyi)
(push p t)
(push p (% 0 0 'quit))
(movni t 1)
(jcall 16 'error)
;;; TYO
(entry em:mail-tyo subr)
em:mail-tyo
(setzm 0 forcedp)
(setom 0 tyop)
(move a @ c)
(caie a cr)
(cain a lf)
(skipa)
(setom 0 noncrlf) ;means a non crlf char has been sent
tyo1 (aos 0 charpos)
(idpb a outpoint) ;put it there
(sosg 0 outbytes) ;ready to send?
(pushj p cmail-sendit)
(caie a lf)
(jrst 0 true)
forceit
(skipn 0 noncrlf)
(jrst 0 true) ;only crlf's so far
(skipn 0 send-lines) ;if T then just return
(jrst 0 fmail-sendit)
(movei tt 't)
(camn tt send-lines)
(jrst 0 true)
(sosle 0 skipp) ;ready to do it?
(jrst 0 true)
(jrst 0 fmail-sendit)
;;; special entry for Refresh case only
force2 (skipe 0 send-lines) ;if T then just return
(popj p)
(jrst 0 fmail-sendit)
;;; FORCE OUTPUT
fmail-sendit
(setom 0 forcedp)
(setz b)
(jrst 0 mail-sendit)
cmail-sendit
(movei tt cont-bit)
(jrst 0 mail-sendit)
em:mail-force-output
(entry em:mail-force-output subr)
(skipe 0 forcedp)
(jrst 0 true)
(setz b) ;continuation
mail-sendit
(setzm 0 noncrlf)
(setzm 0 charpos)
(setzm 0 tyop)
(move a vsend-lines)
(movem a skipp)
(movei a outmail) ;address of buffer
(movem a (+ mailbox 2))
(move a outbytes)
(movei a (+ noutbytes 1))
(sub a outbytes)
(movei t 1) ;1 in t means long
(caile a maxshort) ;short enough
(jrst 0 send-message) ;nope
(setz t) ;0 in T means short
(hrlzi tt outmail)
(hrri tt (+ mailbox 3))
(blt tt (+ mailbox (- mlblksize 1))) ;move to the right place
(iori b short-bit)
send-message
(hrl tt b) ;swap
(hrri tt sexp-type)
(skipe 0 (special -em:e-commands-))
(hrri tt ecommand-type)
(movem tt (+ mailbox 1))
(movns 0 a)
(hrlzm a (+ mailbox 2))
(movei a outmail)
(hrrm a (+ mailbox 2))
(move a thisjob)
(hrli a epr) ;epr validation
(movem a mailbox)
(mail 5 jobnum) ;mail it
(jsp tt wait-for-clear)
(skipa)
(jrst 0 wrongj)
(skipe 0 (special sail-mail-interrupt))
(jrst 0 sm1)
(hrlzi a mailbox)
(hrri a (+ mailbox 1))
(setzm 0 mailbox)
(blt a (+ mailbox (- mlblksize 1))) ;zero it
sm1 (move a outpointtem) ;setup output byte count
(movem a outpoint)
(movei a (+ noutbytes 1))
(movem a outbytes)
(jumpe t sm2) ;don't hang around
(pushj p wait-ok) ;wait for acknowledgment
(pushj p em:mail-type)
(came a 'ok)
(jrst 0 false)
sm2 (hrlzi a outmail)
(hrri a (+ outmail 1))
(setzm 0 outmail)
(blt a (+ outmail (- rdblk 1))) ;zero it
(jrst 0 true)
;;; Routine to get to a buffer from E with not all <cr>s in it
(entry em:file-align subr)
(args em:file-align (nil . 0))
em:file-align
(move tt inpoint) ;copy of byte pointer
(move t inbytes)
filalgn2
(aosle 0 t)
(pushj p filalgn1)
(ildb a tt)
(skipn 0 a)
(jrst 0 alnxtx)
(caie a tab)
(cain a space)
(jrst 0 alnxtx)
(caie a cr) ;a cr?
(cain a lf) ;a lf?
(skipa)
(jrst 0 true)
alnxtx (ibp 0 inpoint)
(aos 0 inbytes)
(jrst 0 filalgn2)
filalgn1
(pushj p mail-refresh)
(move tt inpoint)
(move t inbytes)
(popj p)
;;; This routine gets fresh mail to initialize the reader
mail-refresh
real-mail-refresh
(skipn 0 (special sail-mail-interrupt))
(jrst 0 mr2)
(setom 0 mailinp)
(setzm 0 (special sail-mail-interrupt))
(jrst 0 em:process-mail)
(setzm 0 (special sail-mail-interrupt))
mr2 (skipn 0 mailinp) ;mail received?
(jrst 0 mr1) ;get the next batch
mr3 (pushj p em:wait-mail) ;wait for response
(jrst 0 em:process-mail) ;get the mail
mr1 (skipn 0 tyi-inited)
(skipn 0 resume-pc) ;ready for crock?
(jrst 0 mr3) ;nope
(pushj p @ resume-pc) ;get the rest
(popj p) ;continue
;;; This routine does a jobread into the right spot.
transfer-buffer
(setom 0 tyi-inited) ;ready to read
(move a transfer-spot)
(hrrzm a (+ jobread 2))
(pushj p zinmail)
(move a (+ mailbox 2))
(hrl a inwords)
(movem a (+ jobread 1))
(movei tt jobread)
(calli tt 400050) ;jobrd
(jrst 0 false)
(jrst 0 send-ok)
transfer-short
(pushj p zinmail)
(hrlzi a (+ mailbox 3)) ;move from here
(hrr a transfer-spot) ;to here
(move tt transfer-spot)
(addi tt (- mlblksize 1))
(blt a 0 tt) ;transfer 29
(setom 0 tyi-inited) ;ready to read
(popj p)
zinmail
(hrlz a transfer-spot)
(move tt transfer-spot)
(aos 0 tt)
(hrr a tt)
(setzm 0 @ transfer-spot)
(move tt transfer-spot)
(add tt transfer-size)
(blt a -1 tt)
(popj p)
(entry em:clear-input subr)
(args em:clear-input (nil . 0))
(setzm 0 tyop)
(setzm 0 forcedp)
(setzm 0 noncrlf)
(setzm 0 untyif)
(setzm 0 inbytes)
(setzm 0 rinbytes)
(move a temuntyipdl)
(movem a untyipdl)
(setom 0 explicit-eof)
(setzm 0 mailinp)
(setzm 0 tyi-inited)
(pushj p zinmail)
(movei a 't)
(popj p)
wait-ok
(722←33 0 mailint) ; mskcl
(skipn 0 (special sail-mail-interrupt))
(mail 1 mailbox) ;WRCV
(721←33 0 mailint) ;imskst
(move tt (+ mailbox 2))
(setzm 0 (special sail-mail-interrupt))
(hrrzs tt) ;flush short?
(caie tt ok-type)
(jrst 0 true)
(jrst 0 false)
(entry em:send-simple-message subr)
(args em:send-simple-message (nil . 1))
(cain a 'initiate)
(jrst 0 initiate-message)
(cain a 'ok)
(jrst 0 ok-message)
(cain a 'hold-it)
(jrst 0 hold-it-message)
(cain a 'eof)
(jrst 0 eof-message)
(movei a 'Invalid-message)
(popj p)
eof-message
(movei a explicit-eof-type)
(jrst 0 send-simple-message)
initiate-message
(movei a initiate-type)
(jrst 0 send-simple-message)
ok-message
(movei a ok-type)
(jrst 0 send-simple-message)
hold-it-message
(movei a 102)
(movem a (+ mailb2 2))
(movei a interrupt-type)
send-simple-message
(movem a (+ mailb2 1))
(move b thisjob)
(hrl b epr)
(movem b mailb2)
(movem b mailbox)
(mail 5 jobn2)
(jsp tt wait-for-clear)
(jrst 0 true)
(jrst 0 false)
wait-for-clear
(setz a)
(calli a 31)
(jrst 0 -2 tt)
(entry em:send-control-char subr)
(args em:send-control-char (nil . 1))
send-control-char
(movei t -1) ;count
(move tt outchartem)
(move a 0 a) ;get character
(trne a 600) ;control and meta?
(jrst 0 cm1)
(trze a 200) ;control bit
(pushj p c1) ;push control
(trze a 400) ;meta bit
(pushj p m1) ;push meta
cm2 (aos 0 charpos)
(idpb a tt)
(movei a ecommand-type)
(hrli a short-bit) ;short control chars
(movem a (+ mailb2 1))
(hrlzm t (+ mailb2 2))
(movei a outmail)
(hrrm a (+ mailb2 2))
(move b thisjob)
(hrl b epr)
(movem b mailb2)
(movem b mailbox)
(mail 5 jobn2)
(jsp tt wait-for-clear)
(jrst 0 true)
(jrst 0 false)
c1 (movei r 2) ;alpha
(aos 0 charpos)
(idpb r tt) ;send it
(sos 0 t) ;decrement
(popj p)
m1 (movei r 3) ;beta
(aos 0 charpos)
(idpb r tt) ;send it
(sos 0 t) ;decrement
(popj p)
cm1 (movei r #o26)
(aos 0 charpos)
(idpb r tt)
(sos 0 t)
(trz r 600)
(jrst 0 cm2)
(entry em:init subr)
(args em:init (nil . 0))
(setzm 0 withinrov)
(setzm 0 delayedsexp)
(movei tt inmail)
(movem tt transfer-spot)
(movei tt blksize)
(movem tt transfer-size)
(movei tt (+ noutbytes 1))
(movem tt outbytes)
(movei tt (+ nrovbytes 1))
(movem tt rovbytes)
(calli tt #o30)
(movem tt thisjob)
(jrst 0 fix1)
send-ok
(movei a ok-type)
(movem a (+ mailb2 1))
(move b thisjob)
(hrli b epr)
(movem b mailb2)
(mail 5 jobn2)
(jsp tt wait-for-clear)
(jrst 0 true)
(jrst 0 false)
(entry em:eval-protect subr)
(args em:eval-protect (nil . 0))
(movei a mailbox)
(movem a (special sail-mail-address))
(movei a 't)
(popj p)
(entry em:eval-unprotect subr)
(args em:eval-unprotect (nil . 0))
(movei a 'nil)
(movem a (special sail-mail-address))
(popj p)
;;; Routines for obtaining the values of readonly variables
(entry em:readonly-init subr)
(args em:readonly-init (nil . 0))
(722←33 0 mailint) ;imskcl
;inited mailinp
;0 0 resume-pc
;0 -1 in but not inited, must refresh
;-1 0 ok
;-1 -1 contradiction
(setom 0 withinrov)
(move tt tyop)
(movem tt otyop)
(move tt tyi-inited)
(movem tt otyi-inited)
(move tt transfer-spot)
(movem tt otransfer-spot)
(move tt transfer-size)
(movem tt otransfer-size)
(setzm 0 tyop)
(jrst 0 true)
(entry em:make-sixbit subr)
(args em:make-sixbit (nil . 1))
;;; Takes list of variables and returns an alist of variable-value pairs
sixmak (movei b '6) ;direct lift from faslap
(call 2 'pnget)
(hlrz a 0 a)
(move tt 0 a)
(idpb tt rovpoint) ;put it there
(sosle 0 rovbytes) ;ready to send?
(jrst 0 fix1) ;return fixnum
;;; Read only variable mail message
(entry em:force-readonly-message subr)
(args em:force-readonly-message (nil . 0))
em:force-readonly-message
(setzm 0 tyi-inited)
(movei a rovmail) ;address of buffer
(movem a (+ mailbox 2))
(move a rovbytes)
(movei a (+ nrovbytes 1))
(sub a rovbytes)
(movei t 1) ;1 in t means long
(caile a rovmaxshort) ;short enough
(jrst 0 rovsend-message) ;nope
(setz t) ;0 in T means short
(hrlzi tt rovmail)
(hrri tt (+ mailbox 3))
(blt tt (+ mailbox (- mlblksize 1))) ;move to the right place
(iori b short-bit)
rovsend-message
(hrl tt b) ;swap
(hrri tt readonlyvar-type)
(movem tt (+ mailbox 1))
(movns 0 a)
(hrlzm a (+ mailbox 2))
(movei a rovmail)
(hrrm a (+ mailbox 2))
(move a thisjob)
(hrli a epr) ;epr validation
(movem a mailbox)
(mail 5 jobnum) ;mail it
(jsp tt wait-for-clear)
(skipa)
(jrst 0 wrongj)
(hrlzi a rovmail) ;zeros output buffer
(hrri a (+ rovmail 1))
(setzm 0 rovmail)
(blt a (+ rovmail (- rovmailblksize 1))) ;zero it
(skipe 0 (special sail-mail-interrupt))
(jrst 0 rm1)
(hrlzi a mailbox) ;zeros mailbox
(hrri a (+ mailbox 1)) ;unless interrupt caught some mail
(setzm 0 mailbox)
(blt a (+ mailbox (- mlblksize 1))) ;zero it
rm1 (move a rovpointtem) ;setup output byte count
(movem a rovpoint)
(movei a (+ nrovbytes 1))
(setzm 0 rinbytes)
(movem a rovbytes)
(jumpe t true) ;don't hang around
(pushj p wait-ok) ;wait for acknowledgment
(pushj p em:mail-type)
(came a 'ok)
(jrst 0 false)
(jrst 0 true)
(entry em:get-next-readonly subr)
(args em:get-next-readonly (nil . 0))
(skipn 0 tyi-inited)
(pushj p rovmail-refresh)
(aosle 0 rinbytes)
(jrst 0 rovdone)
(ildb tt irovpoint) ;get it
(jsp t fxcons)
(push fxp a) ;save it
(aosle 0 rinbytes)
(jrst 0 (- rovdone 1))
(ildb tt irovpoint)
(jsp t fxcons)
(pop fxp b)
(jcall 2 'xcons)
(sub fxp (% 0 0 1 1))
rovdone
(move tt otyi-inited)
(movem tt tyi-inited)
(move tt otransfer-spot)
(movem tt transfer-spot)
(move tt otransfer-size)
(movem tt transfer-size)
(move tt otyop)
(movem tt tyop)
(setzm 0 withinrov)
(721←33 0 mailint) ;imskst
(seto tt)
(jrst 0 fix1)
rovmail-refresh
rm2 (pushj p em:wait-mail)
(pushj p em:process-mail)
(cain a 'readonlyvars)
(popj p)
(jrst 0 rm2)
;;; debugging routines
(entry em:inbytes subr)
(move tt inbytes)
(jrst 0 fix1)
(entry em:rinbytes subr)
(move tt rinbytes)
(jrst 0 fix1)
(entry em:get-rov-mail subr)
(pushj p rovmail-refresh)
(movei a 't)
(popj p)
;;; Storage for Mail routines
delayedsexp (0) ;states whether an sexpr came in during
;an input buffer dry demon execution
withinrov (0)
transfer-spot (0)
otransfer-spot (0)
transfer-size (0)
otransfer-size (0)
svdacs (block 10.)
send-lines (0)
noncrlf (0)
vsend-lines (0)
skipp (0)
tyop (0)
otyop (0)
forcedp (0) ;output already forced
inwords (0) ;number of words to input via jobread
explicit-eof (-1) ;nil
mailint (4000000000)
jobnum (-1)
(0 0 mailbox)
mailbox (block mlblksize) ;mail
jobn2 (0)
(0 0 mailb2)
mailb2(block mlblksize) ;short mail
inmail (block blksize) ;text
outmail (block blksize) ;text
rovmail (block rovmailblksize)
stack (block 20)
untyipdl (777760←22 0 stack)
temuntyipdl (777760←22 0 stack)
untyif (0)
inpoint (1100←22 0 (- inmail 1))
inpointtem (1100←22 0 (- inmail 1))
irovpoint (4400←22 0 (- rovmail 1))
irovpointtem (4400←22 0 (- rovmail 1))
rinbytes (0)
inbytes (0)
outpoint (700←22 0 (- outmail 1))
outpointtem (700←22 0 (- outmail 1))
rovpoint (4400←22 0 (- rovmail 1))
rovpointtem (4400←22 0 (- rovmail 1))
outchartem (700←22 0 (+ mailb2 2))
outbytes (0 0 (+ noutbytes 1))
rovbytes (0 0 (+ nrovbytes 1))
mailinp (0) ;-1 means in
charpos (0)
thisjob (0)
tyi-inited (0) ;ready to read. 0 = nil, -1 = t
otyi-inited (0) ;ready to read. 0 = nil, -1 = t
resume-pc (0) ;where to get more chars
eofchar (0) ;eof char
jobread (0)
(0)
(0 0 inmail)
()
(or (and (boundp 'em:no-init) em:no-init)
(progn
(em:mail-interface-initialize)))